home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
Visual Basic Graphics Programming (2nd Edition)
/
Visual Basic Graphics Programming 2nd Edition.iso
/
OldSrc
/
CH11
/
SRC
/
DEPTH2.FRM
< prev
next >
Wrap
Text File
|
1997-01-17
|
10KB
|
395 lines
VERSION 4.00
Begin VB.Form DepthSortForm
Appearance = 0 'Flat
BackColor = &H00C0C0C0&
Caption = "Depth Sort"
ClientHeight = 5685
ClientLeft = 1230
ClientTop = 870
ClientWidth = 6030
BeginProperty Font
name = "MS Sans Serif"
charset = 1
weight = 700
size = 8.25
underline = 0 'False
italic = 0 'False
strikethrough = 0 'False
EndProperty
ForeColor = &H80000008&
Height = 6375
KeyPreview = -1 'True
Left = 1170
LinkTopic = "Form1"
ScaleHeight = 5685
ScaleWidth = 6030
Top = 240
Width = 6150
Begin VB.TextBox PhiText
Height = 285
Left = 3600
TabIndex = 6
Text = "0.7854"
Top = 5400
Width = 855
End
Begin VB.TextBox ThetaText
Height = 285
Left = 2040
TabIndex = 4
Text = "25.7611"
Top = 5400
Width = 855
End
Begin VB.TextBox RText
Height = 285
Left = 480
TabIndex = 2
Text = "10.0000"
Top = 5400
Width = 855
End
Begin VB.PictureBox Pict
AutoRedraw = -1 'True
BackColor = &H00C0C0C0&
Height = 5295
Left = 0
ScaleHeight = -14
ScaleLeft = -7
ScaleMode = 0 'User
ScaleTop = 7
ScaleWidth = 15.926
TabIndex = 0
Top = 0
Width = 6015
End
Begin MSComDlg.CommonDialog LoadDialog
Left = 4920
Top = 5280
_version = 65536
_extentx = 847
_extenty = 847
_stockprops = 0
End
Begin VB.Label Label1
Caption = "Phi"
Height = 255
Index = 2
Left = 3240
TabIndex = 5
Top = 5400
Width = 375
End
Begin VB.Label Label1
Caption = "Theta"
Height = 255
Index = 1
Left = 1440
TabIndex = 3
Top = 5400
Width = 495
End
Begin VB.Label Label1
Caption = "R"
Height = 255
Index = 0
Left = 240
TabIndex = 1
Top = 5400
Width = 255
End
Begin VB.Menu mnuFile
Caption = "&File"
Begin VB.Menu mnuFileLoad
Caption = "&Load..."
Shortcut = ^L
End
Begin VB.Menu mnuFileSep
Caption = "-"
End
Begin VB.Menu mnuFileExit
Caption = "E&xit"
End
End
End
Attribute VB_Name = "DepthSortForm"
Attribute VB_Creatable = False
Attribute VB_Exposed = False
Option Explicit
' Location of viewing eye.
Dim EyeR As Single
Dim EyeTheta As Single
Dim EyePhi As Single
Const Dtheta = PI / 20
Const Dphi = PI / 20
Const Dr = 1
' Location of focus point.
Const FocusX = 0#
Const FocusY = 0#
Const FocusZ = 0#
Dim Projector(1 To 4, 1 To 4) As Single
Dim ThePicture As ObjPicture
Dim ShowingParameters As Boolean
' *******************************************************
' Rotate the points in the cube and draw the cube.
' *******************************************************
Private Sub DrawData(pic As Object)
Dim x As Single
Dim y As Single
Dim z As Single
Dim edge_pen As Long
Dim old_pen As Long
Dim fill_brush As Long
Dim old_brush As Long
Dim status As Long
Dim t1(1 To 4, 1 To 4) As Single
Dim t2(1 To 4, 1 To 4) As Single
Dim T12(1 To 4, 1 To 4) As Single
Dim T123(1 To 4, 1 To 4) As Single
Dim pt As Point3D
MousePointer = vbHourglass
' Prevent overflow errors when drawing lines
' too far out of bounds.
On Error Resume Next
' Cull backfaces.
ThePicture.Culled = False
m3SphericalToCartesian EyeR, EyeTheta, EyePhi, x, y, z
ThePicture.Cull x, y, z
' Clip faces behind the center of projection.
ThePicture.ClipEye EyeR
' Transform coordinates into pixels.
m3Scale t1, _
Pict.ScaleX(1, Pict.ScaleMode, vbPixels), _
Pict.ScaleY(1, Pict.ScaleMode, vbPixels), _
1
m3Translate t2, _
-Pict.ScaleX(Pict.ScaleLeft, Pict.ScaleMode, vbPixels), _
-Pict.ScaleY(Pict.ScaleTop, Pict.ScaleMode, vbPixels), _
0
m3MatMultiply T12, t1, t2
m3MatMultiplyFull T123, Projector, T12
' Transform the points.
ThePicture.ApplyFull T123
' Clear the screen. We must do this before
' selecting the pen and brush since Cls resets
' the pen and brush to default values.
pic.Cls
' Get a pen and brush.
edge_pen = CreatePen(PS_SOLID, pic.DrawWidth, pic.ForeColor)
old_pen = SelectObject(pic.hdc, edge_pen)
fill_brush = CreateSolidBrush(pic.BackColor)
old_brush = SelectObject(pic.hdc, fill_brush)
' Display the data.
ThePicture.DrawOrdered pic, EyeR
pic.Refresh
' Restore the old pen and brush.
edge_pen = SelectObject(pic.hdc, old_pen)
fill_brush = SelectObject(pic.hdc, old_brush)
status = DeleteObject(edge_pen)
status = DeleteObject(fill_brush)
' Display the viewing parameters.
ShowViewingParameters
MousePointer = vbDefault
End Sub
Sub ShowViewingParameters()
ShowingParameters = True
RText.Text = Format$(EyeR, "0.0000")
ThetaText.Text = Format$(EyeTheta, "0.0000")
PhiText.Text = Format$(EyePhi, "0.0000")
RText.Refresh
ThetaText.Refresh
PhiText.Refresh
ShowingParameters = False
End Sub
Private Sub Form_KeyDown(KeyCode As Integer, Shift As Integer)
Select Case KeyCode
Case vbKeyLeft
EyeTheta = EyeTheta - Dtheta
Case vbKeyRight
EyeTheta = EyeTheta + Dtheta
Case vbKeyUp
EyePhi = EyePhi - Dphi
Case vbKeyDown
EyePhi = EyePhi + Dphi
Case Else
Exit Sub
End Select
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub Form_KeyPress(KeyAscii As Integer)
Select Case KeyAscii
Case Asc("+")
EyeR = EyeR + Dr
Case Asc("-")
EyeR = EyeR - Dr
Case Else
Exit Sub
End Select
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub Form_Load()
' Initialize the eye position.
EyeR = 20
EyeTheta = PI * 0.2
EyePhi = PI * 0.05
' Initialize the projection transformation.
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
' Create the data.
CreateData
' Project and draw the data.
DrawData Pict
End Sub
' ***********************************************
' Create some axes initially.
' ***********************************************
Sub CreateData()
Dim pline As ObjPolyline
Set ThePicture = New ObjPicture
Set pline = New ObjPolyline
ThePicture.Objects.Add pline
pline.AddSegment 0, 0, 0, 5, 0, 0
pline.AddSegment 0, 0, 0, 0, 5, 0
pline.AddSegment 0, 0, 0, 0, 0, 5
End Sub
Private Sub mnuFileExit_Click()
Unload Me
End Sub
Private Sub mnuFileLoad_Click()
Dim fname As String
Dim filenum As Integer
Dim txt As String
Dim xmin As Single
Dim ymin As Single
Dim xmax As Single
Dim ymax As Single
' Allow the user to pick a file.
On Error Resume Next
LoadDialog.filename = "*.APF"
LoadDialog.ShowOpen
LoadDialog.Flags = cdlOFNFileMustExist + cdlOFNHideReadOnly
If Err.Number = cdlCancel Then
Unload LoadDialog
Exit Sub
ElseIf Err.Number <> 0 Then
Unload LoadDialog
Beep
MsgBox "Error selecting file.", , vbExclamation
Exit Sub
End If
On Error GoTo 0
fname = LoadDialog.filename
LoadDialog.InitDir = Left$(fname, Len(fname) _
- Len(LoadDialog.FileTitle) - 1)
' Clear the picture.
Set ThePicture = Nothing
' Open the file.
filenum = FreeFile
Open fname For Input As #filenum
' Make sure it's an Object Picture File.
Input #filenum, txt
If txt <> "3D APF PICTURE" Then
Close filenum
Caption = "Show APF"
Beep
MsgBox "Error reading file """ & fname & """.", , vbExclamation
Exit Sub
End If
' Read the picture.
Set ThePicture = New ObjPicture
ThePicture.FileInput filenum
' Close the file.
Close filenum
Caption = "Show APF [" & LoadDialog.FileTitle & "]"
' Refresh the display.
DrawData Pict
End Sub
Private Sub PhiText_Change()
If ShowingParameters Then Exit Sub
EyePhi = CSng(PhiText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub RText_Change()
If ShowingParameters Then Exit Sub
EyeR = CSng(RText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub
Private Sub ThetaText_Change()
If ShowingParameters Then Exit Sub
EyeTheta = CSng(ThetaText.Text)
m3PProject Projector, m3Perspective, EyeR, EyePhi, EyeTheta, FocusX, FocusY, FocusZ, 0, 1, 0
DrawData Pict
End Sub